home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / LISP / MACROS.S < prev    next >
Encoding:
Text File  |  1992-05-17  |  3.8 KB  |  111 lines
  1. ;
  2. ; Following are a few macro definitions which implement constructs in other
  3. ; LISPs. They are not intended to be fully compatible to COMMON LISP or any
  4. ; other dialect, but are included as examples of how other constructs may
  5. ; be implemented, and how Scheme itself can be extended. Note also that the
  6. ; examples lack sufficient error checking - feel free to modify, extend,
  7. ; and add to any or all of macros for your own purposes.
  8. ; 
  9.  
  10. ;
  11. ; CATCH/THROW - A catch form evaluates some subforms in such a way that, if
  12. ; a throw is executed during such evaluation, the evaluation is aborted at 
  13. ; that point and the catch form returns a value specified by the throw. The 
  14. ; catch/throw mechanism works even if the throw form is not within the lexical 
  15. ; scope of the catch. 
  16. ;
  17. ; The tags used for this implementation of catch/throw can be either symbols, 
  18. ; strings, or numbers. Note the use of fluids and continuations in this
  19. ; implementation.
  20. ; 
  21.  
  22. (macro catch        ;(catch tag expression)
  23.    (lambda (e)
  24.       (let ((tag  (cadr e))
  25.         (form (caddr e)))
  26.        (cond ((string? tag)
  27.           (set! tag (string->symbol tag)))
  28.          ((number? tag)
  29.           (set! tag (implode (explode tag))))
  30.          ((and (pair? tag) (eq? (car tag) 'quote))
  31.           (set! tag (cadr tag))) )
  32.  
  33.      `(call/cc (fluid-lambda (,tag) ,form)))))
  34.  
  35.  
  36. (macro throw        ;(throw tag value)
  37.    (lambda (e)
  38.       (let ((tag (cadr e))
  39.         (value (caddr e)))
  40.        (cond ((string? tag)
  41.           (set! tag (string->symbol tag)))
  42.          ((number? tag)
  43.           (set! tag (implode (explode tag))))
  44.          ((and (pair? tag) (eq? (car tag) 'quote))
  45.           (set! tag (cadr tag))) )
  46.  
  47.        `(if (and (fluid-bound? ,tag)
  48.              (continuation? (fluid ,tag)))
  49.            ((fluid ,tag) ,value)
  50.            (error "Bad tag on throw" ,tag)))))
  51.  
  52. ; 
  53. ; PROG - The prog construct allows one to write in a statement-oriented style 
  54. ; (ala FORTRAN), using go statements that can refer to tags in the body of the 
  55. ; prog. Modern LISP programming tends to use prog infrequently, however the 
  56. ; following exercise is a good example of how Scheme may be extended to take
  57. ; on characteristics of other LISPs.
  58. ;
  59.  
  60. (macro go
  61.   (lambda (form)
  62.      (if (integer? (cadr form))
  63.         `(implode (explode ,(cadr form)))
  64.      ;else
  65.         (cdr form))))
  66.  
  67. (macro prog
  68.   (lambda (form)
  69.     (letrec 
  70.       ((tagstart '())
  71.        (buildvars
  72.      (lambda (proglist varlist)
  73.            (if (null? proglist)
  74.                varlist
  75.                ;else
  76.                (buildvars (cdr proglist)
  77.                           (if (pair? (car proglist))
  78.                               `(,(car proglist) ,@varlist)
  79.                               ;else
  80.                               `( (,(car proglist) '()) ,@varlist))))))
  81.        (buildtags
  82.      (lambda (tbodys)
  83.            (if (null? tagstart)
  84.                tbodys
  85.                ;else
  86.                (buildtags 
  87.                  `( ( ,(car tagstart) 
  88.                        (lambda () ,@(getbody (cdr tagstart) '())))
  89.                     ,@tbodys)))))
  90.        (getbody 
  91.      (lambda (exprs body)
  92.            (cond ((null? exprs)
  93.                   (set! tagstart '())
  94.                   (reverse! `((return ()) ,@body)))
  95.                  ((or (symbol? (car exprs)) (integer? (car exprs)))
  96.                   (set! tagstart
  97.                         (if (integer? (car exprs))
  98.                 `(,(implode (explode (car exprs))) ,@(cdr exprs))
  99.                             ;else
  100.                 exprs))
  101.                   (reverse! `( (,(car tagstart)) ,@body)))
  102.                  (else    
  103.            (getbody (cdr exprs) `(,(car exprs) ,@body)))))))
  104.       
  105.       (let ((letrec_body (getbody (cddr form) '()))
  106.             (letrec_vars (reverse! (buildtags (buildvars (cadr form) '())))))
  107.         
  108.         `(call/cc (lambda (return)    
  109.                 (letrec ,letrec_vars ,@letrec_body)))) )))          
  110.  
  111.